home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / debug.lisp < prev    next >
Encoding:
Text File  |  1992-05-25  |  4.1 KB  |  137 lines
  1. ;;; -*- Package: MIPS; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: debug.lisp,v 1.12 92/05/18 19:54:03 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: debug.lisp,v 1.12 92/05/18 19:54:03 ram Exp $
  15. ;;;
  16. ;;; Compiler support for the new whizzy debugger.
  17. ;;;
  18. ;;; Written by William Lott.
  19. ;;; 
  20. (in-package "MIPS")
  21.  
  22.  
  23. (define-vop (debug-cur-sp)
  24.   (:translate current-sp)
  25.   (:policy :fast-safe)
  26.   (:results (res :scs (sap-reg)))
  27.   (:result-types system-area-pointer)
  28.   (:generator 1
  29.     (move res csp-tn)))
  30.  
  31. (define-vop (debug-cur-fp)
  32.   (:translate current-fp)
  33.   (:policy :fast-safe)
  34.   (:results (res :scs (sap-reg)))
  35.   (:result-types system-area-pointer)
  36.   (:generator 1
  37.     (move res fp-tn)))
  38.  
  39. (define-vop (read-control-stack)
  40.   (:translate stack-ref)
  41.   (:policy :fast-safe)
  42.   (:args (object :scs (sap-reg) :target sap)
  43.      (offset :scs (any-reg negative-immediate zero immediate)))
  44.   (:arg-types system-area-pointer positive-fixnum)
  45.   (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
  46.   (:results (result :scs (descriptor-reg)))
  47.   (:result-types *)
  48.   (:generator 5
  49.     (sc-case offset
  50.       ((zero)
  51.        (inst lw result object 0))
  52.       ((negative-immediate immediate)
  53.        (inst lw result object (* (tn-value offset) vm:word-bytes)))
  54.       ((any-reg)
  55.        (inst addu sap object offset)
  56.        (inst lw result sap 0)))
  57.     (inst nop)))
  58.  
  59. (define-vop (write-control-stack)
  60.   (:translate %set-stack-ref)
  61.   (:policy :fast-safe)
  62.   (:args (object :scs (sap-reg) :target sap)
  63.      (offset :scs (any-reg negative-immediate zero immediate))
  64.      (value :scs (descriptor-reg) :target result))
  65.   (:arg-types system-area-pointer positive-fixnum *)
  66.   (:results (result :scs (descriptor-reg)))
  67.   (:result-types *)
  68.   (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
  69.   (:generator 5
  70.     (sc-case offset
  71.       ((zero)
  72.        (inst sw value object 0))
  73.       ((negative-immediate immediate)
  74.        (inst sw value object (* (tn-value offset) vm:word-bytes)))
  75.       ((any-reg)
  76.        (inst addu sap object offset)
  77.        (inst sw value sap 0)))
  78.     (move result value)))
  79.  
  80. (define-vop (code-from-mumble)
  81.   (:policy :fast-safe)
  82.   (:args (thing :scs (descriptor-reg)))
  83.   (:results (code :scs (descriptor-reg)))
  84.   (:temporary (:scs (non-descriptor-reg)) temp)
  85.   (:variant-vars lowtag)
  86.   (:generator 5
  87.     (let ((bogus (gen-label))
  88.       (done (gen-label)))
  89.       (loadw temp thing 0 lowtag)
  90.       (inst srl temp vm:type-bits)
  91.       (inst beq temp bogus)
  92.       (inst sll temp (1- (integer-length vm:word-bytes)))
  93.       (unless (= lowtag vm:other-pointer-type)
  94.     (inst addu temp (- lowtag vm:other-pointer-type)))
  95.       (inst subu code thing temp)
  96.       (emit-label done)
  97.       (assemble (*elsewhere*)
  98.     (emit-label bogus)
  99.     (inst b done)
  100.     (move code null-tn)))))
  101.  
  102. (define-vop (code-from-lra code-from-mumble)
  103.   (:translate lra-code-header)
  104.   (:variant vm:other-pointer-type))
  105.  
  106. (define-vop (code-from-function code-from-mumble)
  107.   (:translate function-code-header)
  108.   (:variant vm:function-pointer-type))
  109.  
  110. (define-vop (make-lisp-obj)
  111.   (:policy :fast-safe)
  112.   (:translate make-lisp-obj)
  113.   (:args (value :scs (unsigned-reg) :target result))
  114.   (:arg-types unsigned-num)
  115.   (:results (result :scs (descriptor-reg)))
  116.   (:generator 1
  117.     (move result value)))
  118.  
  119. (define-vop (get-lisp-obj-address)
  120.   (:policy :fast-safe)
  121.   (:translate get-lisp-obj-address)
  122.   (:args (thing :scs (descriptor-reg) :target result))
  123.   (:results (result :scs (unsigned-reg)))
  124.   (:result-types unsigned-num)
  125.   (:generator 1
  126.     (move result thing)))
  127.  
  128. (define-vop (function-word-offset)
  129.   (:policy :fast-safe)
  130.   (:translate function-word-offset)
  131.   (:args (fun :scs (descriptor-reg)))
  132.   (:results (res :scs (unsigned-reg)))
  133.   (:result-types positive-fixnum)
  134.   (:generator 5
  135.     (loadw res fun 0 function-pointer-type)
  136.     (inst srl res vm:type-bits)))
  137.